home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1993…ch: Other People's Memory / ADC Developer CD (1993-03) (''Other People's Memory'')_iso / Dev.CD Mar 93.iso / Development Platforms / LISP Related / LISP Goodies / McCartney-library 1.1 / Example / simple-scatter-plot.lisp < prev   
Encoding:
Text File  |  1992-09-02  |  6.8 KB  |  204 lines  |  [TEXT/CCL2]
  1. ;;; simple-scatter-plot.lisp
  2. ;;;
  3. ;;; Paul McCartney, Spring 1992
  4. ;;;
  5. ;;; Copyright © 1992 Paul McCartney.  All Rights Reserved.
  6. ;;; 
  7. ;;; Washington University Medical Informatics Training Program
  8. ;;;
  9. ;;; DESCRIPTION:
  10. ;;;
  11. ;;; This file is a sample implementation of a basic scatter plot.  It demostrates
  12. ;;; the "number-line-view" and "scatter-plot-view" that are provided.
  13. ;;;
  14. ;;; USE:
  15. ;;;
  16. ;;; See the end of this file for sample window creation.
  17. ;;;
  18. ;;; HISTORY:
  19. ;;;
  20. ;;; 6/30/92 Created. - PM
  21. ;;;
  22.  
  23. (in-package :cl-user)
  24.  
  25. (require :graphics-tools)
  26. (require :number-line-view)
  27. (require :scatter-plot-view)
  28. (require :pop-up-view)
  29. (require :quickdraw)
  30.  
  31.  
  32. ;;;;
  33. ;;;; POP UP VIEW
  34. ;;;;
  35.  
  36. (defun draw-point-info (puv size data)
  37.   (declare (ignore size))
  38.   (let ((x (first data))
  39.         (y (second data)))
  40.     (with-fore-color *blue-color*
  41.       (#_MoveTo 10 18)
  42.       (format puv "Point:"))
  43.     (with-fore-color *light-blue-color*
  44.       (#_MoveTo 50 18)
  45.       (format puv "(~s, ~s)" x y)) ))
  46.  
  47.  
  48. (defvar *pop-up-view*)
  49. (setf *pop-up-view*
  50.   (make-instance 'pop-up-view
  51.     :pop-up-view-size #@(120 30)
  52.     :pop-up-view-draw-fn #'draw-point-info
  53.     :color-list (list 
  54.                  :background *yellow-color*
  55.                  :frame *dark-green-color*
  56.                  :shadow *green-color*)))
  57.  
  58.  
  59. ;;;;
  60. ;;;; SCATTER PLOT POINT SPECIALIZATION
  61. ;;;;
  62.  
  63. (defclass specialized-point (scatter-plot-point)
  64.   ((color :initarg :color :accessor color)
  65.    (outline-color :initarg :outline-color :accessor outline-color)) )
  66.  
  67.  
  68. (defmethod draw-scatter-plot-point ((point specialized-point) view topleft bottomright)
  69.   (with-fore-color (color point)
  70.     (paint-oval view topleft bottomright))
  71.   (with-fore-color (outline-color point) 
  72.     (frame-oval view topleft bottomright)) )
  73.  
  74.  
  75. ;;;;
  76. ;;;; SIMPLE SCATTER PLOT
  77. ;;;;
  78.  
  79. (defclass simple-scatter-plot (window)
  80.   ((vertical-scroll-width :initarg :vertical-scroll-width 
  81.                           :accessor vertical-scroll-width)
  82.    (horizontal-scroll-width :initarg :horizontal-scroll-width 
  83.                             :accessor horizontal-scroll-width)
  84.    (window-grow-rect :accessor window-grow-rect 
  85.                      :initform (make-record :rect :topleft #@(315 220) 
  86.                                             :bottomright #@(800 600))))
  87.   (:default-initargs 
  88.     :window-title "Simple Scatter Plot"
  89.     :view-position #@(50 50)
  90.     :view-size #@(500 300)
  91.     :window-type :document-with-grow
  92.     :vertical-scroll-width 50
  93.     :horizontal-scroll-width 50
  94.     :color-p t) )
  95.  
  96.  
  97. (defmethod initialize-instance ((view simple-scatter-plot) &rest initargs)
  98.   (apply #'call-next-method view initargs)
  99.   (set-back-color view *black-color*)
  100.   (add-scatter-plot-views view)
  101.   (set-view-sizes-and-positions view) )
  102.  
  103.  
  104. (defmethod add-scatter-plot-views ((view simple-scatter-plot))
  105.   (add-subviews view
  106.     (make-instance 'scatter-plot-view
  107.       :view-nick-name 'scatter-plot
  108.       :click-on-point-function 
  109.       #'(lambda (view data)  (puv-display *pop-up-view* (view-container view) data) ))
  110.  
  111.      (make-instance 'number-line-vertical-view  
  112.        :title '("Y" " " "A" "X" "I" "S")
  113.        :dialog-item-action #'(lambda (item) (arrange-scatter-plot (view-container item)))
  114.        :start 0
  115.        :end 600
  116.        :min-value 0
  117.        :max-value 1000
  118.        :color-list (list :title *orange-color* :frame *orange-color* 
  119.                          :numbers *yellow-color*)
  120.        :title-font-spec '("monaco" 9 :bold)
  121.        :mark-font-spec '("courier" 9)
  122.        :view-nick-name 'vertical-scale-bar
  123.        :tick-mark-inc-fn #'(lambda (scale) (find-pixel-increment-v scale 3/10 5)))
  124.  
  125.      (make-instance 'number-line-horizontal-view  
  126.        :title '("X AXIS")
  127.        :dialog-item-action #'(lambda (item) (arrange-scatter-plot (view-container item)))
  128.        :start 0
  129.        :end 72
  130.        :min-value 0
  131.        :max-value 300
  132.        :color-list (list :title *orange-color* :frame *orange-color* 
  133.                          :numbers *yellow-color*)
  134.        :title-font-spec '("monaco" 9 :bold)
  135.        :mark-font-spec '("courier" 9)
  136.        :view-nick-name 'horizontal-scale-bar
  137.        :tick-mark-inc-fn #'(lambda (scale) (find-pixel-increment-h scale 3/4 2)))
  138.      
  139.      (make-instance 'static-text-dialog-item
  140.       :dialog-item-text "Drag number lines to scroll.  Shift-Drag number lines to rescale.  Click on points to inspect."
  141.       :view-position #@(0 0)
  142.       :view-font '("times" 12 :plain)
  143.       :part-color-list (list :text *white-color*))
  144. ))
  145.  
  146.  
  147. (defmethod set-view-sizes-and-positions ((view simple-scatter-plot))
  148.   (let ((scatter-plot (view-named 'scatter-plot view))
  149.         (vertical-scale (view-named 'vertical-scale-bar view))
  150.         (horizontal-scale (view-named 'horizontal-scale-bar view)) )
  151.     (set-view-position vertical-scale #@(0 15))
  152.     (set-view-size vertical-scale 
  153.                    (vertical-scroll-width view)
  154.                    (- (point-v (view-size view)) (vertical-scroll-width view) 15))
  155.     (set-view-position horizontal-scale
  156.                        (vertical-scroll-width view)
  157.                        (+ (point-v (view-size vertical-scale))
  158.                           (point-v (view-position vertical-scale))))
  159.     (set-view-size horizontal-scale
  160.                    (- (point-h (view-size view)) (vertical-scroll-width view))
  161.                    (horizontal-scroll-width view))
  162.     (set-view-position scatter-plot (horizontal-scroll-width view) 15)
  163.     (set-view-size scatter-plot 
  164.                    (point-h (view-size horizontal-scale))
  165.                    (point-v (view-size vertical-scale)))
  166.     (arrange-scatter-plot view) ))
  167.  
  168.  
  169. (defmethod set-view-size ((view simple-scatter-plot) h &optional v)
  170.   (call-next-method view h v)
  171.   (set-view-sizes-and-positions view))
  172.  
  173.  
  174. (defmethod arrange-scatter-plot ((view simple-scatter-plot))
  175.   (let ((scatter-plot (view-named 'scatter-plot view))
  176.         (vertical-scale (view-named 'vertical-scale-bar view))
  177.         (horizontal-scale (view-named 'horizontal-scale-bar view)) )
  178.     (set-scatter-plot-range scatter-plot
  179.                             (number-line-start horizontal-scale)
  180.                             (number-line-end horizontal-scale)
  181.                             (number-line-start vertical-scale)
  182.                             (number-line-end vertical-scale)) ))
  183.  
  184. ;;;;
  185. ;;;; EXTERNAL DATA I/O
  186. ;;;;
  187.  
  188. (defmethod add-data ((view simple-scatter-plot) events)
  189.   (let ((plot (view-named 'scatter-plot view)))
  190.     (add-scatter-plot-points plot events 'specialized-point t)
  191.     (dolist (point (scatter-plot-points plot))
  192.       (setf (color point) 
  193.             (nth (random 4) 
  194.                  (list *red-color* *yellow-color* *green-color* *light-blue-color*)))
  195.       (setf (outline-color point) (change-brightness (color point) 1.7))) ))
  196.  
  197.  
  198. #|
  199. ; Example:  Create the simple scatter plot (assuming *sample-data* has data)
  200.  
  201. (let ((w (make-instance 'simple-scatter-plot :window-show nil)))
  202.   (add-data w *sample-data*)
  203.   (window-select w))
  204. |#